home *** CD-ROM | disk | FTP | other *** search
/ Just Call Me Internet / Just Call Me Internet.iso / prog / atari / m2 / cat3src / cat / storage.i < prev    next >
Text File  |  1997-10-26  |  41KB  |  1,390 lines
  1. IMPLEMENTATION MODULE Storage;
  2. (*$Y+,R-,Z-*)
  3.  
  4. (*-----------------------------------------------------------------------------
  5.  * Copyright Januar 1989 Thomas Tempelmann
  6.  *-----------------------------------------------------------------------------
  7.  * Kurzbeschreibung : Auf StorBase aufgesetzte, systemunabh„ngige Memory-
  8.  *                    verwaltung fr MOS
  9.  *-----------------------------------------------------------------------------
  10.  * Systemversion : MOS 1.1
  11.  * Textversion   : V#0293
  12.  *-----------------------------------------------------------------------------
  13.  * Datum    Vers  Autor  Bemerkung (Arbeitsbericht)
  14.  *-----------------------------------------------------------------------------
  15.  * 14.02.92  2.15 TT     'valid' benutzt Super() statt Supexec() wg. MiNT.
  16.  * 10.11.90  2.14 TT     ALLOCATE/SysAlloc erkennt 0-size sofort
  17.  * 08.11.90       TT     $R-
  18.  * 26.10.90  2.13 TT     Neg. šberl„ufe bei size-Parm bei ALLOCATE/Enlarge weg.
  19.  * 11.10.90  2.12 TT     StorBase.Resize-Aufruf gab zu viel frei.
  20.  * 09.10.90  2.11 TT     DEALLOCATE gibt nix frei, wenn kein FullAcess und
  21.  *                       size # 0; DEALLOCATE ruft ggf. Resize statt DEALLOCATE
  22.  *                       in StorBase, damit shrink immer m”glich ist.
  23.  * 26.09.90  2.10 TT     MaxBlSize wird bei ACCs auf 2KB gesetzt, weil sonst
  24.  *                       gleich meist 32K drauf gehen.
  25.  * 19.08.90  2.9  TT     MemAvail macht keinen Overflow, wenn weniger als 40
  26.  *                       Byte frei sind.
  27.  * 29.07.90  2.8  TT     Available ge„ndert.
  28.  * 23.07.90  2.7  TT     ALLOCATE kann nun auch Speicher < MaxBlSize noch
  29.  *                       anfordern, solange StorBase noch davon was brig hat.
  30.  * 15.07.90  2.6  TT     Kritische StorBase-Routinen werden nur bei
  31.  *                       'FullStorBaseAccess' aufgerufen.
  32.  * 13.06.90       TT     EnterSupervisorMode raus
  33.  * 14.03.90  2.5  TT     ALOCATE/SysAlloc mit size=0 liefern NIL als Ptr.
  34.  *                       (bisher wurde trotzdem ein Header alloziert);
  35.  *                       MemAvail: BlockFullSize wird zus„tzlich vom freien
  36.  *                       Bereich abgezogen
  37.  * 11.01.90  2.4  TT     Verify-Routine in Asm kodiert, prft nun auch
  38.  *                       Pointer auf Gltigkeit, sodaž kein Adr/Bus-Error
  39.  *                       kommen kann; aužerdem wird bei Erkennen eines
  40.  *                       Fehlers die Speicherkette mit den noch intakten
  41.  *                       Daten geschlossen
  42.  * 07.07.89  2.3  TT     Optimierung einige Routinen in Asm
  43.  * 05.06.89  2.3  TT     Nach Freigabe residenter Module wird nun nicht mehr
  44.  *                       Speicherverw. inkonsistent. Grund: 'valid' erkennt nun,
  45.  *                       wenn schon freigegebener Bereich nochmal freigegeben
  46.  *                       wird.
  47.  * 02.06.89  2.3  TT     More liefert ADR (Root) PROC (Resize) und PROC (Verify)
  48.  * 14.05.89  2.2  TT     Es steckt noch ein Fehler entw. in MemSize oder
  49.  *                       DEALLOCATE mit size>0!
  50.  *                       Zur Sicherheit bei blockOK.ubNeg ANDI.L eingefgt
  51.  *                       (weiž aber nicht, ob dies redundant ist).
  52.  * 04.03.89  2.1  TT     getFree: full nicht erkannt, wenn origLen knapp unter
  53.  *                         MaxBlSize lag. newBlock legte aber dann ggf. zuwenig
  54.  *                         Speicher an.
  55.  * 18.02.89  2.0  TT     1. Freigabe zum Testen (an Manuel, MAUS)
  56.  *----------------------------------------------------------------------------*)
  57.  
  58. FROM SYSTEM IMPORT ASSEMBLER, WORD, LONGWORD, ADR, TSIZE, BYTE, ADDRESS;
  59.  
  60. FROM MOSGlobals IMPORT MemArea, InternalFault;
  61.  
  62. FROM MOSConfig IMPORT MaxBlSize;
  63.  
  64. FROM MOSSupport IMPORT ToSuper, ToUser;
  65.  
  66. FROM PrgCtrl IMPORT Accessory, EnvlpCarrier, TermCarrier, CatchProcessTerm,
  67.         SetEnvelope;
  68.  
  69. IMPORT StorBase;
  70.  
  71.  
  72. TYPE
  73.         PtrHead = POINTER TO Head;
  74.  
  75.         HeadLink = RECORD
  76.                      n: INTEGER;  (* rel. offset von block.data *)
  77.                      p: INTEGER;  (* rel. offset von block.data *)
  78.                    END;
  79.  
  80.         Head  = RECORD;           (* werden nur fr used-Bereiche benutzt *)
  81.                   hd: HeadLink;
  82.                   root: INTEGER;  (* rel. Offset von Block.data (pos.Wert) *)
  83.                   level: INTEGER;
  84.                   size: INTEGER;  (* used-Gr”že, kann ungerade sein!     *)
  85.                                   (* -- muž immer vor 'hd.data' stehen   *)
  86.                                   (* damit 'fullBlk' funktioniert!       *)
  87.                   data: BYTE      (* Beginn der Daten *)
  88.                 END;
  89. CONST
  90.         HeadSize = 10;            (* TSIZE (Head ohne data) *)
  91.  
  92. TYPE
  93.         PtrLink = POINTER TO Link;
  94.  
  95.         Link = RECORD
  96.                  next: PtrLink;
  97.                  prev: PtrLink;
  98.                END;
  99.  
  100.         PtrBlock = POINTER TO Block;
  101.  
  102.         Block = RECORD
  103.                   blk: Link;
  104.                   size: LONGINT;  (* Gr”že des verfgbaren Bereichs *)
  105.                                   (*  kann ungerade sein!           *)
  106.                                   (* Bit 30: <full>                 *)
  107.                   CASE : CARDINAL OF
  108.                   | 0: (* full *)
  109.                     level: INTEGER;
  110.                     full: CARDINAL; (* = 0, wenn full *)
  111.                     fullData: BYTE
  112.                   | 1: (* root *)
  113.                     blRov: PtrBlock (* zeigt direkt auf letzten Block *)
  114.                   | 2: (* not full *)
  115.                     hd: HeadLink;
  116.                     hdRov: INTEGER; (* letzer hd, wo alloc durchgef. wurde *)
  117.                     free: LONGINT;  (* gesamter freier Bereich in Block *)
  118.                     hds : BYTE      (* Beginn der Header/Freibereiche *)
  119.                   END
  120.                 END;
  121. CONST
  122.         BlockSize     = 22;  (* TSIZE (Block ohne hds) *)
  123.         BlockFullSize = 16;  (* TSIZE (Block, 0) *)
  124.  
  125.  
  126. VAR Root: Block;
  127.     StorLevel: INTEGER;  (* 0: Sys *)
  128.     _membot, _memtop: ADDRESS;
  129.  
  130.  
  131.  
  132. PROCEDURE abs (bl: PtrBlock; hd: INTEGER): ADDRESS;
  133.   (*$L-*)
  134.   BEGIN
  135.     ASSEMBLER
  136.         ; RETURN ADR (bl^.hds) + LONGCARD (LONG (hd))
  137.         MOVE    -(A3),D0
  138.         MOVE.L  -(A3),A0
  139.         ; ADDA.W  D0,A0
  140.         ; ADDA.W  #BlockSize,A0
  141.         LEA     BlockSize(A0,D0.W),A0
  142.         MOVE.L  A0,(A3)+
  143.     END
  144.   END abs;
  145.   (*$L=*)
  146.  
  147. PROCEDURE rel (bl: PtrBlock; ad: ADDRESS): INTEGER;
  148.   (*$L-*)
  149.   BEGIN
  150.     ASSEMBLER
  151.         ; RETURN SHORT ( ad - ADR (bl^.hds) )
  152.         MOVE.L  -(A3),D0
  153.         MOVE.L  -(A3),A0
  154.         ADDA.W  #BlockSize,A0
  155.         SUB.L   A0,D0
  156.         MOVE.W  D0,(A3)+
  157.     END
  158.   END rel;
  159.   (*$L=*)
  160.  
  161.  
  162. MODULE BlkLists;
  163.  
  164.   IMPORT ASSEMBLER, abs, rel, ADR, Link, PtrBlock, HeadLink, BlockSize;
  165.  
  166.   EXPORT linkBlkIn, linkBlkOut,
  167.          linkHdIn, linkHdOut;
  168.  
  169. (*
  170.   PROCEDURE linkBlkIn (VAR l, at: Link);
  171.     BEGIN
  172.         l.prev:= at.prev;
  173.         l.next:= ADR (at);
  174.         at.prev^.next:= ADR (l);
  175.         at.prev:= ADR (l)
  176.     END linkBlkIn;
  177.  
  178.   PROCEDURE linkBlkOut (VAR l: Link);
  179.     BEGIN
  180.         l.prev^.next:= l.next;
  181.         l.next^.prev:= l.prev
  182.     END linkBlkOut;
  183.  
  184.   PROCEDURE linkHdIn (bl: PtrBlock; VAR l: HeadLink; before: INTEGER);
  185.     VAR at, at2: POINTER TO HeadLink;
  186.     BEGIN
  187.         at:= abs (bl, before);
  188.         l.p:= at^.p;
  189.         l.n:= before;
  190.         at2:= abs (bl, at^.p);
  191.         at2^.n:= rel (bl, ADR (l));
  192.         at^.p:= rel (bl, ADR (l))
  193.     END linkHdIn;
  194.  
  195.   PROCEDURE linkHdOut (bl: PtrBlock; VAR l: HeadLink);
  196.     VAR at: POINTER TO HeadLink;
  197.     BEGIN
  198.         at:= abs (bl, l.p);
  199.         at^.n:= l.n;
  200.         at:= abs (bl, l.n);
  201.         at^.p:= l.p
  202.     END linkHdOut;
  203. *)
  204.  
  205.   (*$L-*)
  206.  
  207.   PROCEDURE linkBlkIn (VAR l, at: Link);
  208.     BEGIN
  209.       ASSEMBLER
  210.         ; l.prev:= at.prev;
  211.         ; l.next:= ADR (at);
  212.         ; at.prev^.next:= ADR (l);
  213.         ; at.prev:= ADR (l)
  214.         MOVE.L  -(A3),A1        ; ADR (at)
  215.         MOVE.L  -(A3),A0        ; ADR (l)
  216.         MOVE.L  Link.prev(A1),A2
  217.         MOVE.L  A2,Link.prev(A0)
  218.         MOVE.L  A1,Link.next(A0)
  219.         MOVE.L  A0,Link.next(A2)
  220.         MOVE.L  A0,Link.prev(A1)
  221.       END
  222.     END linkBlkIn;
  223.  
  224.   PROCEDURE linkBlkOut (VAR l: Link);
  225.     BEGIN
  226.       ASSEMBLER
  227.         ; l.prev^.next:= l.next;
  228.         ; l.next^.prev:= l.prev
  229.         MOVE.L  -(A3),A0        ; ADR (l)
  230.         MOVE.L  Link.prev(A0),A1
  231.         MOVE.L  Link.next(A0),A2
  232.         MOVE.L  A2,Link.next(A1)
  233.         MOVE.L  A1,Link.prev(A2)
  234.       END
  235.     END linkBlkOut;
  236.  
  237.   PROCEDURE linkHdIn (bl: PtrBlock; VAR l: HeadLink; before: INTEGER);
  238.     VAR at, at2: POINTER TO HeadLink;
  239.     BEGIN
  240.       ASSEMBLER
  241.         MOVE    -(A3),D0        ; before
  242.         MOVE.L  -(A3),A0        ; ADR (l)
  243.         MOVE.L  -(A3),A1        ; bl
  244.         ; at:= abs (bl, before);
  245.         ; MOVE.L  A1,A2
  246.         ; ADDA.W  D0,A2
  247.         ; ADDA.W  #BlockSize,A2      ; at
  248.         LEA     BlockSize(A1,D0.W),A2
  249.         ; l.p:= at^.p;
  250.         MOVE.W  HeadLink.p(A2),D1  ; at^.p
  251.         MOVE.W  D1,HeadLink.p(A0)
  252.         ; l.n:= before;
  253.         MOVE.W  D0,HeadLink.n(A0)
  254.         ; BERECHNE rel (bl, ADR (l)) NACH A0
  255.         ADDA.W  #BlockSize,A1
  256.         SUBA.L  A1,A0
  257.         ; at2:= abs (bl, at^.p);
  258.         ADDA.W  D1,A1              ; at2
  259.         ; at2^.n:= rel (bl, ADR (l));
  260.         ; at^.p:= rel (bl, ADR (l))
  261.         MOVE.W  A0,HeadLink.n(A1)
  262.         MOVE.W  A0,HeadLink.p(A2)
  263.       END
  264.     END linkHdIn;
  265.  
  266.   PROCEDURE linkHdOut (bl: PtrBlock; VAR l: HeadLink);
  267.     VAR at: POINTER TO HeadLink;
  268.     BEGIN
  269.       ASSEMBLER
  270.         MOVE.L  -(A3),A0        ; ADR (l)
  271.         MOVE.L  -(A3),A1        ; bl
  272.         ; at:= abs (bl, l.p);
  273.         MOVE.L  A1,A2
  274.         ADDA.W  HeadLink.p(A0),A2
  275.         ADDA.W  #BlockSize,A2      ; at
  276.         ; at^.n:= l.n;
  277.         MOVE.W  HeadLink.n(A0),HeadLink.n(A2)
  278.         ; at:= abs (bl, l.n);
  279.         ADDA.W  HeadLink.n(A0),A1
  280.         ADDA.W  #BlockSize,A1      ; at
  281.         ; at^.p:= l.p
  282.         MOVE.W  HeadLink.p(A0),HeadLink.p(A1)
  283.       END
  284.     END linkHdOut;
  285.  
  286.   (*$L=*)
  287.  
  288.   END BlkLists;
  289.  
  290.  
  291. PROCEDURE setBit6 (VAR i: ARRAY OF BYTE);
  292.   (*$L-*)
  293.   BEGIN
  294.     ASSEMBLER
  295.         SUBQ.L  #2,A3
  296.         MOVEA.L -(A3),A0
  297.         BSET.B  #6,(A0)
  298.     END
  299.   END setBit6;
  300.   (*$L=*)
  301.  
  302. PROCEDURE blkFull (bl: PtrBlock): BOOLEAN;
  303.   (*$L-*)
  304.   BEGIN
  305.     ASSEMBLER
  306.         MOVE.L  -(A3),A0
  307.         BTST    #6,Block.size(A0)
  308.         SNE     D0
  309.         ANDI    #1,D0
  310.         MOVE    D0,(A3)+
  311.     END
  312.   END blkFull;
  313.   (*$L=*)
  314.  
  315. PROCEDURE blkSize (bl: PtrBlock): LONGINT;
  316.   (*$L-*)
  317.   BEGIN
  318.     ASSEMBLER
  319.         MOVE.L  -(A3),A0
  320.         MOVE.L  Block.size(A0),D0
  321.         ANDI.L  #$00FFFFFF,D0
  322.         MOVE.L  D0,(A3)+
  323.     END
  324.   END blkSize;
  325.   (*$L=*)
  326.  
  327. PROCEDURE sizeHd (bl: PtrBlock; hd: INTEGER): INTEGER;
  328.   (*$L-*)
  329.   BEGIN
  330.     ASSEMBLER
  331.         ; hdp:= abs (bl, hd);
  332.         ; RETURN val (hdp^.size)
  333.         MOVE    -(A3),D0
  334.         MOVE.L  -(A3),A0
  335.         MOVE.W  Head.size+BlockSize(A0,D0.W),D0
  336.         ADDQ    #1,D0
  337.         ANDI    #$FFFE,D0
  338.         MOVE    D0,(A3)+
  339.     END;
  340.   END sizeHd;
  341.   (*$L=*)
  342.  
  343. PROCEDURE nextHd (bl: PtrBlock; hd: INTEGER): INTEGER;
  344.   (*$L-*)
  345.   BEGIN
  346.     ASSEMBLER
  347.         ; hdp:= abs (bl, hd);
  348.         ; RETURN hdp^.hd.n
  349.         MOVE    -(A3),D0
  350.         MOVE.L  -(A3),A0
  351.         MOVE.W  Head.hd.n+BlockSize(A0,D0.W),(A3)+
  352.     END;
  353.   END nextHd;
  354.   (*$L=*)
  355.  
  356. PROCEDURE prevHd (bl: PtrBlock; hd: INTEGER): INTEGER;
  357.   (*$L-*)
  358.   BEGIN
  359.     ASSEMBLER
  360.         ; hdp:= abs (bl, hd);
  361.         ; RETURN hdp^.hd.p
  362.         MOVE    -(A3),D0
  363.         MOVE.L  -(A3),A0
  364.         MOVE.W  Head.hd.p+BlockSize(A0,D0.W),(A3)+
  365.     END;
  366.   END prevHd;
  367.   (*$L=*)
  368.  
  369.  
  370. PROCEDURE valid (ad: ADDRESS; VAR bl: PtrBlock;
  371.                   VAR hd: PtrHead; VAR full: BOOLEAN): BOOLEAN;
  372.   (* Verkettung prfen und ggf. 'bl' und 'full' setzen *)
  373.   (*$L-*)
  374.   BEGIN
  375.     (*
  376.       IF ad = NIL THEN RETURN FALSE END;
  377.       full:= fullBlk (ad);
  378.       IF full THEN
  379.         bl:= ad - LONG (BlockFullSize);
  380.       ELSE
  381.         hd:= ad - LONG (HeadSize);
  382.         bl:= ADDRESS (hd) - LONGCARD (LONG (hd^.root + BlockSize));
  383.         IF nextHd (bl, hd.p)) # prevHd (bl, hd.n)) # hd THEN
  384.           RETURN FALSE
  385.         END
  386.       END;
  387.       RETURN bl^.blk.next^.prev = bl^.blk.prev^.next
  388.     *)
  389.     ASSEMBLER
  390. (*        
  391.         SUBQ.L  #4,A7
  392.         JSR     ToSuper
  393.  
  394.         MOVE.L  8,-(A7)         ; bus error vector
  395.         MOVE.L  12,-(A7)        ; address error vector
  396.         LEA     inval(PC),A0
  397.         MOVE.L  A0,8
  398.         MOVE.L  A0,12
  399.         MOVE.L  A7,D1
  400. *)        
  401.         MOVE.L  -(A3),A2        ; full
  402.         MOVE.L  -(A3),D2        ; hd
  403.         MOVE.L  -(A3),A1        ; bl
  404.         MOVE.L  -(A3),A0        ; ad
  405.         
  406.         MOVE.L  A0,D0
  407.         BEQ     inval
  408.         
  409.         TST.W   -2(A0)          ; bei <full> ist 'hd.size' = 0
  410.         SEQ     D0
  411.         ANDI    #1,D0
  412.         MOVE    D0,(A2)         ; full setzen
  413.         
  414.         BEQ     notfull
  415.         
  416.         ; bl:= ad - LONG (BlockFullSize)
  417.         MOVE.L  A0,A2
  418.         SUBA.W  #BlockFullSize,A2
  419.         MOVE.L  A2,(A1)
  420.         BRA     fullend
  421.         
  422.       notfull
  423.         ; hd:= ad - LONG (HeadSize);
  424.         MOVE.L  A0,A2
  425.         SUBA.W  #HeadSize,A2
  426.         MOVE.L  D2,A0
  427.         MOVE.L  A2,(A0)
  428.         ; bl:= ADDRESS (hd) - LONGCARD (LONG (hd^.root + BlockSize));
  429.         MOVE.L  A2,A0                   ; hd retten
  430.         SUBA.W  Head.root(A2),A2
  431.         SUBA.W  #BlockSize,A2
  432.         MOVE.L  A2,(A1)
  433.         
  434.         ; rel (bl, hd):
  435.         MOVE.L  A0,D2           ; hd
  436.         MOVE.L  A2,A1           ; bl
  437.         ADDA.W  #BlockSize,A1
  438.         SUB.L   A1,D2
  439.         ; IF nextHd (bl, hd.p)) # prevHd (bl, hd.n)) # rel (bl, hd) THEN
  440.         MOVE.W  Head.hd.p(A0),D0
  441.         CMP.W   Head.hd.n+BlockSize(A2,D0.W),D2
  442.         BNE     inval
  443.         MOVE.W  Head.hd.n(A0),D0
  444.         CMP.W   Head.hd.p+BlockSize(A2,D0.W),D2
  445.         BNE     inval
  446.         
  447.       fullend
  448.         ; RETURN bl^.blk.next^.prev = bl^.blk.prev^.next
  449.         MOVE.L  Block.blk.next(A2),A1
  450.         MOVE.L  Block.blk.prev(A1),D0
  451.         MOVE.L  Block.blk.prev(A2),A1
  452.         CMP.L   Block.blk.next(A1),D0
  453.         SEQ     D0
  454.         ANDI    #1,D0
  455.         MOVE    D0,(A3)+
  456.         BRA     ende
  457.       inval:
  458.         CLR     (A3)+
  459. (*        MOVE.L  D1,A7 *)
  460.       ende:
  461. (*        MOVE.L  (A7)+,12
  462.         MOVE.L  (A7)+,8
  463.         
  464.         JSR     ToUser
  465.         ADDQ.L  #4,A7
  466. *)    END
  467.   END valid;
  468.   (*$L=*)
  469.  
  470. PROCEDURE incHdSize (hd: PtrHead; siz: CARDINAL);
  471.   (*$L-*)
  472.   BEGIN
  473.     ASSEMBLER
  474.         MOVE.W  -(A3),D0
  475.         MOVE.L  -(A3),A0
  476.         ADD.W   D0,Head.size(A0)
  477.     END
  478.   END incHdSize;
  479.   (*$L=*)
  480.  
  481. PROCEDURE decHdSize (hd: PtrHead; siz: CARDINAL);
  482.   (*$L-*)
  483.   BEGIN
  484.     ASSEMBLER
  485.         MOVE.W  -(A3),D0
  486.         MOVE.L  -(A3),A0
  487.         SUB.W   D0,Head.size(A0)
  488.     END
  489.   END decHdSize;
  490.   (*$L=*)
  491.  
  492. PROCEDURE resize (VAR ad: ADDRESS; len: LONGINT): BOOLEAN;
  493.   (*
  494.    * 'len': wenn pos, dann Abzugswert; wenn neg., dann Vergr”žerungsoffset;
  495.    *   wenn Null, dann ganz freigeben.
  496.    * 'ad' bleibt unver„ndert, wenn RETURN FALSE
  497.    *)
  498.  
  499.   VAR hd: PtrHead; bl: PtrBlock; ok, full: BOOLEAN;
  500.       i: CARDINAL;
  501.  
  502.   PROCEDURE blkAway;
  503.     BEGIN
  504.       IF Root.blRov = bl THEN Root.blRov:= NIL END;
  505.       linkBlkOut (bl^.blk);
  506.       StorBase.DEALLOCATE (bl, 0)
  507.     END blkAway;
  508.  
  509.   VAR this, freeEnd, freeBeg: INTEGER;
  510.       dumusedbeg, duml, dumfreebeg: INTEGER;
  511.  
  512.   BEGIN (* resize *)
  513.     IF NOT valid (ad,bl,hd,full) THEN
  514.       RETURN FALSE
  515.     END;
  516.     IF full THEN
  517.       (* <full> block: ad zeigt hinter Block(0) *)
  518.       IF len < 0L THEN
  519.         (* Block um 'len' vergr”žern *)
  520.         IF StorBase.FullStorBaseAccess () THEN
  521.           StorBase.Enlarge (bl, -len, ok);
  522.           IF ok THEN bl^.size:= bl^.size + ABS (len) END;
  523.           RETURN ok
  524.         ELSE
  525.           RETURN FALSE
  526.         END
  527.       ELSIF (len > 0L) AND (len < blkSize (bl)) THEN
  528.         (* shrink only *)
  529.         bl^.size:= bl^.size - len;
  530.         (* Blockgr”že neu setzen. Plus den Block-Header und aufrunden: *)
  531.         StorBase.Resize (bl, (BlockFullSize + blkSize (bl) + 1) DIV 2 * 2, ok);
  532.         RETURN ok
  533.       ELSE
  534.         blkAway;
  535.         ad:= NIL
  536.       END
  537.     ELSE (* NOT full: *)
  538.       (* ad zeigt hinter Header *)
  539.       IF len < 0L THEN
  540.         (* Block um 'len' vergr”žern *)
  541.         this:= rel (bl, hd);
  542.         freeEnd:= nextHd (bl, this);
  543.         IF freeEnd < 0 THEN freeEnd:= SHORT (blkSize (bl)) END;
  544.         freeBeg:= this + HeadSize + sizeHd (bl, this);
  545.         IF ABS (len) <= LONG (freeEnd - freeBeg) THEN
  546.           i:= SHORT (ABS (len));
  547.           incHdSize (hd, i);
  548.           DEC (bl^.free, (ORD (ODD (hd^.size)) + i) DIV 2 * 2)
  549.         ELSE
  550.           RETURN FALSE
  551.         END
  552.       ELSIF (len > 0L) AND (len < LONG (hd^.size)) THEN
  553.         (* shrink only *)
  554.         i:= SHORT (len);
  555.         decHdSize (hd, i);
  556.         INC (bl^.free, (ORD (NOT ODD (hd^.size)) + i) DIV 2 * 2)
  557.       ELSE
  558.         i:= hd^.size + HeadSize;
  559.         IF ODD (i) THEN INC (i) END;
  560.         INC (bl^.free, i);
  561.         IF bl^.hdRov = rel (bl, hd) THEN
  562.           bl^.hdRov:= prevHd (bl, bl^.hdRov)
  563.         END;
  564.         linkHdOut (bl, hd^.hd);
  565.         IF bl^.free = blkSize (bl) THEN blkAway END;
  566.         (*
  567.           IF hd^.size = 966 THEN
  568.             WriteLn;
  569.             WriteString ('bl^.size: '); WriteString (CardToStr (bl^.size,0)); WriteLn;
  570.             WriteString ('bl^.free: '); WriteString (CardToStr (bl^.free,0)); WriteLn;
  571.             dumfreebeg:= 0;            (* End of last used area *)
  572.             dumusedbeg:= bl^.hd.n;     (* Start of new used area *)
  573.             LOOP
  574.               IF dumusedbeg < 0 THEN
  575.                 duml:= VAL (INTEGER, blkSize (bl)) - dumfreebeg;
  576.                 IF duml > 0 THEN WriteString ('free: '); WriteString (IntToStr (duml,8)); WriteString (IntToStr (nextHd(bl,dumusedbeg),8)); WriteString (IntToStr (prevHd(bl,dumusedbeg),8)); WriteLn; END;
  577.                 EXIT
  578.               ELSE
  579.                 duml:= dumusedbeg - dumfreebeg;
  580.                 IF duml > 0 THEN WriteString ('free: '); WriteString (IntToStr (duml,8)); WriteString (IntToStr (nextHd(bl,dumusedbeg),8)); WriteString (IntToStr (prevHd(bl,dumusedbeg),8)); WriteLn END;
  581.               END;
  582.               WriteString ('used: ');
  583.               WriteString (IntToStr (sizeHd (bl, dumusedbeg),8));
  584.               WriteString (IntToStr (nextHd(bl,dumusedbeg),8));
  585.               WriteString (IntToStr (prevHd(bl,dumusedbeg),8));
  586.               WriteLn;
  587.               dumfreebeg:= dumusedbeg + HeadSize + sizeHd (bl, dumusedbeg);
  588.               dumusedbeg:= nextHd (bl, dumusedbeg)
  589.             END;
  590.           END;
  591.         *)
  592.         ad:= NIL
  593.       END;
  594.     END;
  595.     RETURN TRUE
  596.   END resize;
  597.  
  598. PROCEDURE blockOK (VAR freeBeg, usedBeg: INTEGER;
  599.                    neededLen: LONGINT; bl: PtrBlock): BOOLEAN;
  600.   (*$L-*)
  601.   (* freien Bereich im Block 'bl' suchen *)
  602.   VAR end: INTEGER;
  603.       hd: PtrHead;
  604.   BEGIN
  605.     ASSEMBLER
  606.         (*
  607.           end:= bl^.hdRov;
  608.           usedBeg:= nextHd (bl, end);  (* Start of new used area *)
  609.           IF end < 0 THEN
  610.             freeBeg:= 0;               (* End of last used area *)
  611.           ELSE
  612.             freeBeg:= end + HeadSize + sizeHd (bl, end);
  613.           END;
  614.           LOOP
  615.             IF usedBeg < 0 THEN
  616.               IF (SHORT (blkSize (bl)) - freeBeg) >= SHORT (neededLen) THEN EXIT END;
  617.             ELSE
  618.               IF (usedBeg - freeBeg) >= SHORT (neededLen) THEN EXIT END
  619.             END;
  620.             IF usedBeg = end THEN RETURN FALSE END;
  621.             IF usedBeg < 0 THEN
  622.               freeBeg:= 0
  623.             ELSE
  624.               freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg)
  625.             END;
  626.             usedBeg:= nextHd (bl, usedBeg)
  627.           END;
  628.           RETURN TRUE
  629.         *)
  630.         MOVEM.L D3-D6/A4/A5,-(A7)
  631.  
  632.         MOVE.L  -(A3),A5                        ; A5: bl
  633.  
  634.         ; end:= bl^.hdRov
  635.         MOVE.W  Block.hdRov(A5),D3              ; D3: end
  636.  
  637.         ; usedBeg:= nextHd (bl, end)
  638.         MOVE.W  Head.hd.n+BlockSize(A5,D3.W),D4 ; D4: usedBeg
  639.  
  640.         ; IF end < 0 THEN freeBeg:= 0 ELSE
  641.         ;    freeBeg:= end + HeadSize + sizeHd (bl, end) END;
  642.         CLR.W   D5                              ; D5: freeBeg
  643.         TST.W   D3
  644.         BMI     endNeg
  645.         MOVE    D3,D5
  646.         ADDI.W  #HeadSize+1,D5
  647.         ADD.W   Head.size+BlockSize(A5,D3.W),D5
  648.         ANDI    #$FFFE,D5
  649.       endNeg:
  650.  
  651.         MOVE.L  -(A3),D6                        ; D6: neededLen
  652.  
  653.         MOVEQ   #HeadSize+1,D1
  654.         MOVE    #$FFFE,D2
  655.  
  656.       loop1:
  657.         TST     D4
  658.         BMI     ubNeg
  659.  
  660.       ubPos:
  661.         MOVE    D4,D0
  662.         SUB.W   D5,D0
  663.         CMP.W   D6,D0
  664.         BCC     retTRUE
  665.         CMP     D3,D4
  666.         BEQ     retFALSE
  667.         MOVE    D4,D5
  668.         ADD.W   D1,D5
  669.         ADD.W   Head.size+BlockSize(A5,D4.W),D5
  670.         AND     D2,D5
  671.         MOVE.W  Head.hd.n+BlockSize(A5,D4.W),D4
  672.         BPL     ubPos
  673.  
  674.       ubNeg:
  675.         MOVE.L  Block.size(A5),D0
  676.         ANDI.L  #$00FFFFFF,D0
  677.         SUB.W   D5,D0
  678.         CMP.W   D6,D0
  679.         BCC     retTRUE
  680.         CMP     D3,D4
  681.         BEQ     retFALSE
  682.         CLR     D5
  683.         MOVE.W  Head.hd.n+BlockSize(A5,D4.W),D4
  684.         BRA     loop1
  685.  
  686.       retFALSE:
  687.         CLR     D0
  688.         BRA     return
  689.  
  690.       retTRUE:
  691.         MOVEQ   #1,D0
  692.  
  693.       return:
  694.         MOVE.L  -(A3),A0                ; ADR (usedBeg)
  695.         MOVE    D4,(A0)
  696.         MOVE.L  -(A3),A0                ; ADR (freeBeg)
  697.         MOVE    D5,(A0)
  698.         MOVEM.L (A7)+,D3-D6/A4/A5
  699.         MOVE    D0,(A3)+
  700.     END
  701.   END blockOK;
  702.   (*$L=*)
  703.  
  704.  
  705. PROCEDURE getFree (origLen: LONGINT; VAR neededLen: LONGINT; VAR full: BOOLEAN;
  706.                    VAR blSize: LONGINT; VAR bl: PtrBlock;
  707.                    VAR usedBeg, freeBeg: INTEGER): BOOLEAN;
  708.  
  709.   VAR bl0: PtrBlock;
  710.  
  711.   BEGIN (* getFree *)
  712.     neededLen:= origLen;
  713.     IF ODD (neededLen) THEN INC (neededLen) END;
  714.     full:= (neededLen + LONG(HeadSize)) >= MaxBlSize;
  715.     IF NOT full THEN
  716.       INC (neededLen, HeadSize); (* der Head muž nun auf jeden Fall rein *)
  717.       bl0:= Root.blRov;
  718.       IF bl0 = NIL THEN bl0:= ADDRESS (Root.blk.next) END;
  719.       bl:= bl0;
  720.       REPEAT                (* alle Blocks nach freiem Platz durchsuchen *)
  721.         IF (bl # ADR (Root))
  722.         AND NOT blkFull (bl)
  723.         AND (bl^.free >= neededLen) THEN
  724.           IF blockOK (freeBeg, usedBeg, neededLen, bl) THEN
  725.             RETURN TRUE
  726.           END
  727.         END;
  728.         bl:= ADDRESS (bl^.blk.next)
  729.       UNTIL bl = bl0;
  730.       blSize:= MaxBlSize + LONG (BlockSize)
  731.     ELSE
  732.       blSize:= neededLen + LONG (BlockFullSize)
  733.     END;
  734.     RETURN FALSE
  735.   END getFree;
  736.  
  737.  
  738. PROCEDURE alloc (origLen: LONGINT; level: INTEGER): ADDRESS;
  739.  
  740.   VAR freeBeg, usedBeg: INTEGER;
  741.       bl: PtrBlock;
  742.       blSize, neededLen: LONGINT;
  743.       full: BOOLEAN;
  744.  
  745.   PROCEDURE newBlock (): BOOLEAN;
  746.     BEGIN
  747.       StorBase.SysAlloc (bl, blSize);
  748.       IF bl = NIL THEN RETURN FALSE END;
  749.       IF full THEN
  750.         linkBlkIn (bl^.blk, Root.blk);
  751.         bl^.size:= origLen;
  752.         bl^.level:= level;
  753.         setBit6 (bl^.size);        (* full-Kennung *)
  754.         bl^.full:= 0;              (* full-Kennung *)
  755.       ELSE
  756.         WITH bl^ DO
  757.           linkBlkIn (blk, Root.blk);
  758.           size:= MaxBlSize;  (* 'size' enth. Gr”že des verfgbaren Bereichs *)
  759.           free:= size;
  760.           hd.n:= rel (bl, ADR (hd));
  761.           hd.p:= hd.n;
  762.           hdRov:= hd.n
  763.         END
  764.       END;
  765.       Root.blRov := bl;
  766.       RETURN TRUE
  767.     END newBlock;
  768.  
  769.   PROCEDURE insert (): ADDRESS;
  770.     (* Bereich belegen *)
  771.     VAR hd: PtrHead;
  772.     BEGIN
  773.       (* 'bl' zeigt auf Block, der freien Bereich enth„lt *)
  774.       hd:= abs (bl, freeBeg);
  775.       hd^.size:= SHORT (origLen);
  776.       hd^.level:= level;
  777.       linkHdIn (bl, hd^.hd, usedBeg);
  778.       hd^.root:= freeBeg;
  779.       DEC (bl^.free, CARDINAL (SHORT (neededLen))); (* origLen + HeadSize *)
  780.       bl^.hdRov:= freeBeg;
  781.       Root.blRov := bl;
  782.       RETURN ADR (hd^.data)
  783.     END insert;
  784.  
  785.   VAR lastMax: LONGCARD;
  786.  
  787.   BEGIN (* alloc *)
  788.     IF origLen = 0L THEN
  789.       RETURN NIL
  790.     END;
  791.     IF getFree (origLen, neededLen, full, blSize, bl, usedBeg, freeBeg) THEN
  792.       RETURN insert ()
  793.     END;
  794.     IF NOT newBlock () THEN
  795.       IF full THEN RETURN NIL END;
  796.       (*
  797.        * wenn weniger als MaxBlSize ben”tigt, aber nicht mehr Platz fr
  798.        * einen ganzen neuen Verwaltungsblock da ist, dann eben einen
  799.        * full-Block mit der ben”tigten Size anfordern.
  800.        *)
  801.       lastMax:= MaxBlSize;
  802.       MaxBlSize:= origLen;      (* full-Block erzwingen *)
  803.       IF getFree (origLen, neededLen, full, blSize, bl, usedBeg, freeBeg) THEN
  804.         (* muž FALSE liefern *)
  805.       END;
  806.       MaxBlSize:= lastMax;
  807.       IF NOT newBlock () THEN RETURN NIL END
  808.     END;
  809.     IF full THEN RETURN ADR (bl^.fullData) END;
  810.     IF NOT blockOK (freeBeg, usedBeg, neededLen, bl) THEN
  811.       ASSEMBLER
  812.         TRAP    #6
  813.         DC.W    InternalFault-$C000     ; text follows, caller caused
  814.         ACZ     'Storage allocation error'
  815.         SYNC
  816.       END
  817.     END;
  818.     RETURN insert ()
  819.   END alloc;
  820.  
  821. PROCEDURE Verify (): CARDINAL;
  822.   (*
  823.    * Liefert 0, wenn alle Block- und Head-Verkettungen OK sind
  824.    *
  825.    * VORSICHT: Da auch full-Blocks angelegt werden k”nnen, die
  826.    *   kleiner als MaxBlSize sind, keinesfalls full-Blocks
  827.    *   dahingehend prfen!
  828.    *)
  829.  
  830.   (* VAR bl: PtrBlock; hd: PtrHead; freeBeg, usedBeg: INTEGER; l: LONGINT; *)
  831.   VAR result: CARDINAL;
  832.  
  833. (*$R-*)
  834.   BEGIN
  835.     ASSEMBLER
  836.         LEA     Root,A0
  837.         BRA     loop1
  838.       err1
  839.         BRA.W   errEnd
  840.       loop1
  841.         MOVE.L  Block.blk.next(A0),A0
  842.         MOVE.L  A0,D0
  843.         BTST    #0,D0           ; ungerade?
  844.         BNE     err1
  845.         (* das geht nicht im Fast-RAM des TT!!!
  846.           CMPA.L  _membot,A0      ; < membot?
  847.           BCS     err1
  848.           CMPA.L  _memtop,A0      ; > memtop?
  849.           BCC     err1
  850.         *)
  851.         CMPA.L  #Root,A0
  852.         BEQ.W   exit1           ; ende ? -> OK
  853.         BTST    #6,Block.size(A0)
  854.         BEQ     notFull
  855.         TST.L   Block.size(A0)
  856.         BMI     err1
  857.         MOVE.W  Block.level(A0),D0
  858.         CMP.W   StorLevel,D0
  859.         BHI     err1
  860.         TST.W   Block.full(A0)
  861.         BNE     err1
  862.         BRA     loop1
  863.       notFull
  864.         ; IF bl^.size > (MaxBlSize + LONG (BlockSize)) THEN RETURN 4 END;
  865.         MOVE.L  Block.size(A0),D1
  866. (*  *** das darf nicht geprft werden, weil MaxBlSize variieren kann! ***
  867.         MOVE.L  MaxBlSize,D0
  868.         ADDI.L  #BlockSize,D0
  869.         CMP.L   D0,D1
  870.         BHI     err1
  871. *)
  872.         ; IF bl^.free >= bl^.size THEN RETURN 18 END;
  873.         MOVE.L  Block.free(A0),D0
  874.         CMP.L   D1,D0
  875.         BCC     err1
  876.         ; IF ODD (bl^.size) THEN RETURN 5 END;
  877.         BTST    #0,D1
  878.         BNE     err1
  879.         ; hd:= abs (bl, bl^.hdRov);
  880.         MOVE.W  Block.hdRov(A0),D0
  881.         BTST    #0,D0
  882.         BNE     err1
  883.         LEA     BlockSize(A0,D0.W),A2
  884.         ; IF hd^.root # bl^.hdRov THEN RETURN 6 END;
  885.         CMP.W   Head.root(A2),D0
  886.         BNE     err1
  887.         
  888.         ; usedBeg:= bl^.hd.n;
  889.         MOVE.W  Block.hd.n(A0),D1       ; usedBeg
  890.         ; l:= 0;
  891.         CLR.W   -(A7)                   ; l
  892.         BRA     loop2
  893.       err2
  894.         ADDQ.L  #2,A7
  895.         BRA     err1
  896.       loop2
  897.         ; IF ODD (usedBeg) THEN RETURN 7 END;
  898.         BTST    #0,D1
  899.         BNE     err2
  900.         ; IF usedBeg < 0 THEN
  901.         TST.W   D1
  902.         BPL     notNeg
  903.         ;   IF usedBeg # rel (bl, ADR (bl^.hd)) THEN RETURN 8 END;
  904.         CMPI.W  #$FFF6,D1
  905.         BNE     err2
  906.         ;   EXIT
  907.         BRA     exit2
  908.         ; END;
  909.       notNeg
  910.         ; hd:= abs (bl, usedBeg);
  911.         LEA     BlockSize(A0,D1.W),A2
  912.         ; IF prevHd (bl, nextHd (bl, usedBeg)) # usedBeg THEN RETURN 20 END;
  913.         ; IF ODD (nextHd (bl, usedBeg)) THEN RETURN 14 END;
  914.         MOVE.W  Head.hd.n+BlockSize(A0,D1.W),D2
  915.         BTST    #0,D2
  916.         BNE     err2
  917.         CMP.W   Head.hd.p+BlockSize(A0,D2.W),D1
  918.         BNE     err2
  919.         ; IF nextHd (bl, prevHd (bl, usedBeg)) # usedBeg THEN RETURN 19 END;
  920.         ; IF ODD (prevHd (bl, usedBeg)) THEN RETURN 15 END;
  921.         MOVE.W  Head.hd.p+BlockSize(A0,D1.W),D2
  922.         BTST    #0,D2
  923.         BNE     err2
  924.         CMP.W   Head.hd.n+BlockSize(A0,D2.W),D1
  925.         BNE     err2
  926.         ; IF hd^.size < 0 THEN RETURN 9 END;
  927.         MOVEQ   #0,D2
  928.         MOVE.W  Head.size(A2),D2
  929.         BLE     err2                    ; hd.size <= 0 ?
  930.         ; IF LONG (hd^.size) > bl^.size THEN RETURN 10 END;
  931.         CMP.L   Block.size(A0),D2
  932.         BHI     err2
  933.         ; IF hd^.level > StorLevel THEN RETURN 11 END;
  934.         MOVE.W  Head.level(A2),D0
  935.         CMP.W   StorLevel,D0
  936.         BHI     err2
  937.         ; IF hd^.root # usedBeg THEN RETURN 12 END;
  938.         CMP.W   Head.root(A2),D1
  939.         BNE     err2
  940.         ; INC (l, HeadSize+CARDINAL (hd^.size));
  941.         ; IF ODD (hd^.size) THEN INC (l) END;
  942.         ADDI.W  #HeadSize,D2
  943.         ADDQ    #1,D2
  944.         BCLR    #0,D2
  945.         ADD.W   D2,(A7)
  946.         BCS     err2
  947.         (* macht keinen Sinn, weil 'sizeHd' sowieso Sync macht:
  948.           ; freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg);
  949.           ; IF ODD (freeBeg) THEN RETURN 13 END;
  950.         *)
  951.         ; usedBeg:= nextHd (bl, usedBeg)
  952.         MOVE.W  Head.hd.n+BlockSize(A0,D1.W),D1
  953.         BRA     loop2
  954.       exit2
  955.         ; IF (bl^.size-l) # bl^.free THEN RETURN 17 END
  956.         MOVE.L  Block.size(A0),D0
  957.         MOVEQ   #0,D2
  958.         MOVE.W  (A7)+,D2
  959.         SUB.L   D2,D0
  960.         CMP.L   Block.free(A0),D0
  961.         BEQ     loop1
  962.       errEnd
  963.         LEA     Root,A0
  964.         MOVE.L  A0,Block.blk.next(A0)  ; Liste retten, indem Liste geleert wird
  965.         MOVE.L  A0,Block.blk.prev(A0)
  966.         CLR.L   Block.blRov(A0)
  967.         MOVEQ   #1,D0
  968.         BRA     ende
  969.       exit1
  970.         MOVEQ   #0,D0
  971.       ende
  972.         MOVE    D0,result(A6)
  973.     END;
  974.     RETURN result
  975. (*
  976.     bl:= ADR (Root);
  977.     LOOP
  978.       bl:= ADDRESS (bl^.blk.next);
  979.       IF bl = ADR (Root) THEN EXIT END;
  980.       IF blkFull (bl) THEN
  981.         (* Block-Werte prfen *)
  982.         IF bl^.size < 0L THEN RETURN 1 END;
  983.         IF bl^.level > StorLevel THEN RETURN 2 END;
  984.         IF bl^.full # 0 THEN RETURN 3 END;
  985.       ELSE
  986.         (* Block-Werte prfen *)
  987.         (*** das darf nicht geprft werden, weil MaxBlSize variieren kann! ***
  988.           IF bl^.size > (MaxBlSize + LONG (BlockSize)) THEN RETURN 4 END;
  989.         *)
  990.         IF bl^.free >= bl^.size THEN RETURN 18 END;
  991.         IF ODD (bl^.size) THEN RETURN 5 END;
  992.         hd:= abs (bl, bl^.hdRov);
  993.         IF hd^.root # bl^.hdRov THEN RETURN 6 END;
  994.         usedBeg:= bl^.hd.n;     (* Start of new used area *)
  995.         l:= 0;
  996.         LOOP
  997.           IF ODD (usedBeg) THEN RETURN 7 END;
  998.           IF usedBeg < 0 THEN
  999.             IF usedBeg # rel (bl, ADR (bl^.hd)) THEN RETURN 8 END;
  1000.             EXIT
  1001.           END;
  1002.           hd:= abs (bl, usedBeg);
  1003.           (* Head prfen *)
  1004.           IF nextHd (bl, prevHd (bl, usedBeg)) # usedBeg THEN RETURN 19 END;
  1005.           IF prevHd (bl, nextHd (bl, usedBeg)) # usedBeg THEN RETURN 20 END;
  1006.           IF hd^.size < 0 THEN RETURN 9 END;
  1007.           IF LONG (hd^.size) > bl^.size THEN RETURN 10 END;
  1008.           IF hd^.level > StorLevel THEN RETURN 11 END;
  1009.           IF hd^.root # usedBeg THEN RETURN 12 END;
  1010.           INC (l, HeadSize+CARDINAL (hd^.size));
  1011.           IF ODD (hd^.size) THEN INC (l) END;
  1012.           freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg);
  1013.           IF ODD (freeBeg) THEN RETURN 13 END;
  1014.           IF ODD (nextHd (bl, usedBeg)) THEN RETURN 14 END;
  1015.           IF ODD (prevHd (bl, usedBeg)) THEN RETURN 15 END;
  1016.           IF nextHd (bl, prevHd (bl, usedBeg))
  1017.            # prevHd (bl, nextHd (bl, usedBeg)) THEN RETURN 16 END;
  1018.           usedBeg:= nextHd (bl, usedBeg)
  1019.         END;
  1020.         IF (bl^.size-l) # bl^.free THEN RETURN 17 END
  1021.       END;
  1022.     END;
  1023.     RETURN 0
  1024. *)
  1025.   END Verify;
  1026. (*$R=*)
  1027. (*$R-*)
  1028.  
  1029.  
  1030. PROCEDURE Inconsistent (): BOOLEAN;
  1031.   BEGIN
  1032.     RETURN StorBase.Inconsistent () OR (Verify () # 0)
  1033.   END Inconsistent;
  1034.  
  1035.  
  1036. PROCEDURE ALLOCATE ( VAR addr: ADDRESS; size: LONGCARD );
  1037.   (*$L-*)
  1038.   BEGIN
  1039.     ASSEMBLER
  1040.         ; addr:= alloc (size, StorLevel);
  1041.         CLR.L   D0
  1042.         MOVE.L  -(A3),D1        ; size
  1043.         BLE     error
  1044.         MOVE.L  D1,(A3)+
  1045.         MOVE    StorLevel,(A3)+
  1046.         JSR     alloc
  1047.         MOVE.L  -(A3),D0
  1048.       error
  1049.         MOVE.L  -(A3),A0        ; addr
  1050.         MOVE.L  D0,(A0)
  1051.     END;
  1052.   END ALLOCATE;
  1053.   (*$L=*)
  1054.  
  1055. PROCEDURE SysAlloc ( VAR addr: ADDRESS; size: LONGCARD );
  1056.   (*$L-*)
  1057.   BEGIN
  1058.     ASSEMBLER
  1059.         ; addr:= alloc (size, 0);
  1060.         CLR.L   D0
  1061.         MOVE.L  -(A3),D1        ; size
  1062.         BLE     error
  1063.         MOVE.L  D1,(A3)+
  1064.         CLR     (A3)+
  1065.         JSR     alloc
  1066.         MOVE.L  -(A3),D0
  1067.       error
  1068.         MOVE.L  -(A3),A0        ; addr
  1069.         MOVE.L  D0,(A0)
  1070.     END;
  1071.   END SysAlloc;
  1072.   (*$L=*)
  1073.  
  1074.  
  1075. PROCEDURE DEALLOCATE ( VAR addr: ADDRESS; size: LONGCARD );
  1076.   BEGIN
  1077.     IF LONGINT (size) < 0 THEN
  1078.       size:= MAX (LONGINT)
  1079.     END;
  1080.     IF NOT resize (addr, size) THEN
  1081.       (* versuchen wir's mit StorBase... *)
  1082.       IF (size # 0) & NOT StorBase.FullStorBaseAccess () THEN
  1083.         (* nichts freigeben *)
  1084.         RETURN
  1085.       END;
  1086.       StorBase.DEALLOCATE (addr, size)
  1087.     END;
  1088.   END DEALLOCATE;
  1089.  
  1090.  
  1091. PROCEDURE Available ( size: LONGCARD ): BOOLEAN;
  1092. (*
  1093.   VAR freeBeg, usedBeg: INTEGER;
  1094.       bl: PtrBlock;
  1095.       blSize, neededLen: LONGINT;
  1096.       full: BOOLEAN;
  1097. *)
  1098.   VAR ad: ADDRESS;
  1099.   BEGIN
  1100.     (* Alt:
  1101.         IF getFree (size, neededLen, full, blSize, bl, usedBeg, freeBeg) THEN
  1102.           RETURN TRUE
  1103.         ELSE
  1104.           RETURN StorBase.Available (blSize)
  1105.         END
  1106.     *)
  1107.     (* 29.7.90: *)
  1108.     ALLOCATE (ad, size);
  1109.     IF ad = NIL THEN RETURN FALSE END;
  1110.     DEALLOCATE (ad, 0);
  1111.     RETURN TRUE
  1112.   END Available;
  1113.  
  1114.  
  1115. PROCEDURE MemSize ( addr: ADDRESS ): LONGCARD;
  1116.   VAR hd: PtrHead; bl: PtrBlock; full: BOOLEAN;
  1117.   BEGIN
  1118.     IF valid (addr,bl,hd,full) THEN
  1119.       IF full THEN
  1120.         RETURN blkSize (bl)
  1121.       ELSE
  1122.         RETURN LONG (hd^.size)
  1123.       END
  1124.     ELSE
  1125.       IF StorBase.FullStorBaseAccess () THEN
  1126.         RETURN StorBase.MemSize (addr)
  1127.       ELSE
  1128.         RETURN 0
  1129.       END
  1130.     END
  1131.   END MemSize;
  1132.  
  1133.  
  1134. PROCEDURE MemAvail (): LONGCARD;
  1135.   VAR l: LONGINT;
  1136.   BEGIN
  1137.     (* Aus Programmierfaulheit suchen wir nicht extra in den Blocks
  1138.      * nach dem gr”žten Block sondern fragen nur StorBase.
  1139.      *)
  1140.     l:= INT (StorBase.MemAvail ()) - LONG (BlockSize+BlockFullSize+2);
  1141.     IF l < 0 THEN l:= 0 END;
  1142.     RETURN l
  1143.   END MemAvail;
  1144.  
  1145.  
  1146. PROCEDURE AllAvail (): LONGCARD;
  1147.   
  1148.   VAR bl: PtrBlock; av: LONGINT;
  1149.  
  1150.   BEGIN
  1151.     av:= StorBase.AllAvail ();
  1152.     bl:= ADR (Root);
  1153.     LOOP
  1154.       bl:= ADDRESS (bl^.blk.next);
  1155.       IF bl = ADR (Root) THEN EXIT END; (* wir haben alle Blocks durch *)
  1156.       IF NOT blkFull (bl) THEN
  1157.         av:= av + bl^.free
  1158.       END;
  1159.     END;
  1160.     RETURN av
  1161.   END AllAvail;
  1162.  
  1163.  
  1164. PROCEDURE Keep ( addr: ADDRESS );
  1165.   VAR hd: PtrHead; bl: PtrBlock; full: BOOLEAN;
  1166.   BEGIN
  1167.     IF valid (addr,bl,hd,full) THEN
  1168.       IF full THEN
  1169.         bl^.level:= 0
  1170.       ELSE
  1171.         hd^.level:= 0
  1172.       END
  1173.     ELSE
  1174.       StorBase.Keep (addr)
  1175.     END
  1176.   END Keep;
  1177.  
  1178.  
  1179. PROCEDURE Enlarge ( VAR addr: ADDRESS; add: LONGCARD; VAR ok: BOOLEAN );
  1180.   BEGIN
  1181.     ok:= FALSE;
  1182.     IF LONGINT (add) >= 0 THEN
  1183.       IF NOT resize (addr, -LONGINT (add)) THEN
  1184.         IF StorBase.FullStorBaseAccess () THEN
  1185.           StorBase.Enlarge (addr, add, ok)
  1186.         END
  1187.       ELSE
  1188.         ok:= TRUE
  1189.       END
  1190.     END
  1191.   END Enlarge;
  1192.   
  1193.  
  1194. PROCEDURE TrailAvail (ad: ADDRESS): LONGCARD;
  1195.   VAR hd: PtrHead; bl: PtrBlock; full: BOOLEAN;
  1196.   BEGIN
  1197.     IF valid (ad,bl,hd,full) THEN
  1198.       RETURN 0 (* !!! hier fehlt was *)
  1199.     ELSE
  1200.       RETURN StorBase.TrailAvail (ad)
  1201.     END;
  1202.   END TrailAvail;
  1203.  
  1204.  
  1205. PROCEDURE More (id:INTEGER;p:ADDRESS);
  1206.   (*$L-*)
  1207.   BEGIN
  1208.     ASSEMBLER
  1209.         MOVE.L  -(A3),A0
  1210.         MOVE.W  -(A3),D0
  1211.         CMPI.W  #$4EF1,D0
  1212.         BNE     trail
  1213.         MOVE.L  (A0)+,(A3)+
  1214.         MOVE.L  (A0)+,(A3)+
  1215.         MOVE.L  (A0)+,(A3)+
  1216.         ; Enlarge ( VAR addr: ADDRESS; len: LONGCARD; VAR ok: BOOLEAN );
  1217.         JMP     Enlarge
  1218.       trail
  1219.         CMPI.W  #$4EF2,D0
  1220.         BNE     getRoot
  1221.         MOVE.L  (A0)+,(A3)+
  1222.         MOVE.L  A0,-(A7)
  1223.         ; TrailAvail (ad: ADDRESS): LONGCARD;
  1224.         JSR     TrailAvail
  1225.         MOVE.L  (A7)+,A0
  1226.         MOVE.L  -(A3),(A0)
  1227.         BRA     ende
  1228.       getRoot
  1229.         CMPI.W  #$4EF3,D0
  1230.         BNE     _verify
  1231.         MOVE.L  #Root,(A0)
  1232.         BRA     ende
  1233.       _verify
  1234.         CMPI.W  #$4EF4,D0
  1235.         BNE     _resize
  1236.         MOVE.L  #Verify,(A0)
  1237.         BRA     ende
  1238.       _resize
  1239.         CMPI.W  #$4EF5,D0
  1240.         BNE     ende
  1241.         MOVE.L  #resize,(A0)
  1242.       ende
  1243.     END
  1244.   END More;
  1245.   (*$L=*)
  1246.  
  1247. (* --------------------------------- *)
  1248. (* --------------------------------- *)
  1249.  
  1250. PROCEDURE terminate;
  1251.  
  1252.   VAR bl1, bl: PtrBlock; ad: ADDRESS;
  1253.   VAR usedBeg: INTEGER; hd: PtrHead;
  1254.  
  1255.   (*$L-*)
  1256.   BEGIN
  1257.     ASSEMBLER
  1258.         ; bl:= ADDRESS (Root.blk.next);
  1259.         MOVE.L  Root,A0
  1260.  
  1261.         ; LOOP
  1262.       loopBeg
  1263.         ;   IF bl = ADR (Root) THEN EXIT END; (* wir haben alle Blocks durch *)
  1264.         CMPA.L  #Root,A0
  1265.         BEQ     exitLoop
  1266.         ;     bl1:= ADDRESS (bl^.blk.next);
  1267.         MOVE.L  (A0),A2
  1268.         ;     IF blkFull (bl) THEN
  1269.         BTST    #6,Block.size(A0)
  1270.         BEQ     notFull
  1271.         ;       IF bl^.level = StorLevel THEN
  1272.         MOVE.W  Block.level(A0),D0
  1273.         CMP.W   StorLevel,D0
  1274.         BNE     notLev
  1275.         ;         ad:= ADR (bl^.fullData);
  1276.         ;         DEALLOCATE (ad, 0)
  1277.         PEA     Block.fullData(A0)
  1278.         MOVE.L  A7,(A3)+
  1279.         CLR.L   (A3)+
  1280.         MOVE.L  A2,-(A7)
  1281.         JSR     DEALLOCATE
  1282.         MOVE.L  (A7)+,A2
  1283.         ADDQ.L  #4,A7
  1284.         ;       END
  1285.       notLev
  1286.         BRA       wasFull
  1287.         ;     ELSE
  1288.       notFull
  1289.         ;     usedBeg:= bl^.hd.n;       (* Start of new used area *)
  1290.         MOVE.W  Block.hd.n(A0),D0
  1291.         ;     WHILE usedBeg >= 0 DO
  1292.       whileBeg
  1293.         TST.W   D0
  1294.         BMI     whileEnd
  1295.         ;       hd:= abs (bl, usedBeg);
  1296.         ; MOVE.L  A0,A1
  1297.         ; ADDA.W  D0,A1
  1298.         ; ADDA.W  #BlockSize,A1
  1299.         LEA     BlockSize(A0,D0.W),A1
  1300.         ;       usedBeg:= nextHd (bl, usedBeg);
  1301.         MOVE.W  Head.hd.n+BlockSize(A0,D0.W),D0
  1302.         ;       IF hd^.level = StorLevel THEN
  1303.         MOVE.W  Head.level(A1),D1
  1304.         CMP.W   StorLevel,D1
  1305.         BNE     notLev2
  1306.         ;         ad:= ADR (hd^.data);
  1307.         ;         DEALLOCATE (ad, 0)
  1308.         PEA     Head.data(A1)
  1309.         MOVE.L  A7,(A3)+
  1310.         CLR.L   (A3)+
  1311.         MOVEM.L D0/A0/A2,-(A7)
  1312.         JSR     DEALLOCATE
  1313.         MOVEM.L (A7)+,D0/A0/A2
  1314.         ADDQ.L  #4,A7
  1315.         ;       END
  1316.       notLev2
  1317.         ;     END
  1318.         BRA     whileBeg
  1319.       whileEnd
  1320.         ;   END;
  1321.       wasFull
  1322.         ;   bl:= bl1
  1323.         MOVE.L  A2,A0
  1324.         ; END;
  1325.         BRA     loopBeg
  1326.       exitLoop
  1327.         ; DEC (StorLevel) (* wird zu Null, wenn Prg terminiert; somit werden *)
  1328.                           (* bei resid. Prgs dann die Allocs wie SysAlloc be-*)
  1329.                           (* handelt; ein neuer Prozež startet wieder mit    *)
  1330.                           (* Level 1                                         *)
  1331.         SUBQ.W  #1,StorLevel
  1332.     END
  1333.   END terminate;
  1334.   (*$L=*)
  1335.  
  1336. (*$L-*)
  1337. PROCEDURE chgLevel ( doInc: BOOLEAN; child: BOOLEAN; VAR c: INTEGER );
  1338.   BEGIN
  1339.     ASSEMBLER
  1340.         SUBQ.L  #4,A3
  1341.         MOVE.L  -(A3),D0
  1342.         TST     D0              ; child
  1343.         BEQ     ende
  1344.         SWAP    D0
  1345.         TST     D0
  1346.         BNE     inc
  1347.         JMP     terminate
  1348.       inc
  1349.         ADDQ.W  #1,StorLevel
  1350.       ende
  1351.     END
  1352.   END chgLevel;
  1353. (*$L=*)
  1354.  
  1355.  
  1356. VAR ehdl: EnvlpCarrier;
  1357.     thdl: TermCarrier;
  1358.     wsp: MemArea;
  1359.  
  1360. BEGIN (* main *)
  1361.   WITH Root DO
  1362.     blk.prev:= ADR (Root);
  1363.     blk.next:= ADR (Root);
  1364.     blRov:= NIL
  1365.   END;
  1366.   StorLevel:= 1;
  1367.   IF MaxBlSize = 0L THEN
  1368.     IF Accessory () THEN
  1369.       MaxBlSize:= 2048;
  1370.     ELSE
  1371.       MaxBlSize:= StorBase.MemAvail () DIV 40L;
  1372.     END
  1373.   END;
  1374.   IF MaxBlSize > $7F00L THEN MaxBlSize:= $7F00 END;
  1375.   IF ODD (MaxBlSize) THEN DEC (MaxBlSize) END;
  1376.   CatchProcessTerm (thdl,terminate,wsp);
  1377.   SetEnvelope (ehdl,chgLevel,wsp);
  1378.   ASSEMBLER
  1379.         PEA     X(PC)
  1380.         MOVE    #38,-(A7)
  1381.         TRAP    #14
  1382.         ADDQ.L  #6,A7
  1383.         BRA     CONT
  1384.       X MOVE.L  $432,_membot
  1385.         MOVE.L  $436,_memtop
  1386.         RTS
  1387.       CONT
  1388.   END
  1389. END Storage.
  1390.